(DEFPROP CYCOMBFNS
(CYCOMBFNS MOLECULES SUPERATOMPARTITIONS MAXUNSATL
SUPERATOMS COMPUTEFV CLBYVALENCE RINGS
FVPARTITIONS RINGSKELETONS NOFV-RINGS DAISIES
NOLOOPEDRINGS ROWS BIVALENTPARTITIONS
FREEVALENCESIZE NODES COLLECTFV TRIMZEROS CATALOG
STRUCWITH2NODES CATALOG3 DAISY SINGLERING
BIVCHAIN CONNECT COPYSTRUC DISCONNECT FINDCTE
FIRSTOFNODES LASTOFNODES LISTBYVALENCE PUTFVN
PUTFVS PUTNEWNODE PUTNEWNODEINCT NODEVALENCE
VALENCETYPE SINGLERINGS INSERTMARKERS DELETE)
VALUE)
(DEFPROP MOLECULES
(LAMBDA
(CL U)
(IF (ZEROP U)
THEN
(GENMOL CL)
ELSE
(FOR NEW SAP IN (SUPERATOMPARTITIONS CL U)
FOR NEW S IN (SUPERATOMS (SUPERATOMPARTS SAP))
NCONC FIRST NIL (GENMOL (APPEND (CLCREATE S)
(REMAININGATOMS
SAP))))))
EXPR)
(DEFPROP
SUPERATOMPARTITIONS
(LAMBDA
(CL U)
(PROG
(CL1)
(SETQ CL1 (FOR NEW PR IN CL WHEN (EQUAL (VALENCE (CAR PR))
1.0)
LIST PR))
(SETQ CL (CLDIFF CL CL1))
(RETURN
(FOR NEW PARTSIZE := (2.0 (CLCOUNT CL))
FOR NEW VHAT IN (CLPARTS CL PARTSIZE)
AS NEW REMATS IS (APPEND CL1 (CLDIFF CL VHAT))
FOR NEW #PARTS := (1.0 (QUOTIENT PARTSIZE 2.0))
FOR NEW PARTITION IN (CLPARTITIONSN VHAT #PARTS 2.0
9999.0)
AS NEW VI IS (CLCREATE PARTITION)
AS NEW MXUI IS (MAXUNSATL VI)
WHEN MXUI FOR NEW UI IN (NUMPARTITIONS*
U 1.0 MXUI (MAPCAR (QUOTE CDR)
VI))
XLIST
(SUPERATOMPARTITION
REMAININGATOMS = REMATS SUPERATOMPARTS =
(PROG (CVI CVN M VI2 CUI VI3)
(SETQ VI3 VI)
VILOOP
(IF (NULL VI3)
THEN
(RETURN VI2))
(SETQ CVI (CAAR VI3))
(SETQ CVN (CDAR VI3))
(SETQ VI3 (CDR VI3))
LOOPM
(SETQ M 0.0)
LOOPCVN
(SETQ M (ADD1 M))
(SETQ CVN (SUB1 CVN))
(SETQ CUI (CAR UI))
(SETQ UI (CDR UI))
(IF (AND (NOT (ZEROP CVN))
(EQUAL CUI (CAR UI)))
THEN
(GO LOOPCVN))
(SETQ VI2 (CONS (CONS (CONS CUI CVI)
M)
VI2))
(IF (ZEROP CVN)
THEN
(GO VILOOP)
ELSE
(GO LOOPM))))))))
EXPR)
(DEFPROP
MAXUNSATL
(LAMBDA
(PC)
(FOR
NEW PART-NUM IN PC LIST
(PROG (N TD M)
(SETQ N (SETQ TD (SETQ M 0.0)))
(FOR NEW PR IN (CAR PART-NUM)
DO
(SETQ N (PLUS N (CDR PR)))
(SETQ TD (PLUS TD (TIMES (CDR PR)
(VALENCE (CAR PR)))))
(SETQ M (MAX M (VALENCE (CAR PR)))))
(RETURN (FIX (TIMES .5 (PLUS 2.0 TD (TIMES -2.0 N)
(MIN -1.0
(DIFFERENCE
TD
(TWICE M))))))))))
EXPR)
(DEFPROP SUPERATOMS (LAMBDA
(UCL-COMP)
(GROUPRADS (FOR NEW UCLN IN UCL-COMP LIST
(CONS (RINGS (CAAR UCLN)
(CDAR UCLN))
(CDR UCLN)))))
EXPR)
(DEFPROP COMPUTEFV
(LAMBDA
(U CL)
(PROG (TD N)
(SETQ TD (SETQ N 0.0))
(FOR NEW PR IN CL DO
(SETQ TD (PLUS (TIMES (VALENCE (CAR PR))
(CDR PR))
TD))
(SETQ N (PLUS (CDR PR)
N)))
(RETURN (PLUS 2.0 TD (TIMES -2.0 (PLUS N U))))))
EXPR)
(DEFPROP CLBYVALENCE
(LAMBDA
(CL)
(PROG2 (SETQ CL (GROUPBY (FUNCTION (LAMBDA
(PR)
(VALENCE
(CAR PR))))
CL))
(FOR NEW I := (2.0 (MAXLIST (MAPCAR (QUOTE CAR)
CL)))
LIST
(LMASSOC I CL NIL))))
EXPR)
(DEFPROP RINGS
(LAMBDA
(U CL)
(PROG (FV)
(SETQ FV (COMPUTEFV U CL))
(SETQ CL (CLBYVALENCE CL))
(RETURN (FOR NEW SKELETON IN
(RINGSKELETONS FV (MAPCAR (QUOTE
CLCOUNT)
CL))
NCONC FIRST NIL (STRUCTURESWITHATOMS
CL SKELETON)))))
EXPR)
(DEFPROP
FVPARTITIONS
(LAMBDA
(FV VL)
(FOR NEW FVP IN (FVPARTITION1 FV (CDR VL)
1.0)
AS NEW FVR IS (ROWS FVP)
XLIST
(FVPARTITION FVR = FVR NEWVL =
(FOR NEW ROW IN FVR AS NEW COL IN (CONS NIL FVP)
AS NEW V IN VL LIST
(PLUS V (PLUSLIST ROW)
(MINUS (PLUSLIST COL)))))))
EXPR)
(DEFPROP RINGSKELETONS (LAMBDA (FV VL)
(FOR NEW FVPART IN (FVPARTITIONS
FV VL)
FOR NEW STRUC IN
(NOFV-RINGS (NEWVL FVPART))
NCONC FIRST NIL
(ATTACHFVS (FVR FVPART)
STRUC)))
EXPR)
(DEFPROP NOFV-RINGS (LAMBDA
(VL)
(PROG (MNLPS MXLPS SUMREST)
(SETQ SUMREST (PLUSLIST (CDR VL)))
(IF (ZEROP SUMREST)
THEN
(RETURN (SINGLERINGS (CAR VL)))
ELSEIF
(EQUAL SUMREST 1.0)
THEN
(RETURN (DAISIES VL)))
(SETQ MNLPS (MINLOOPS VL))
(SETQ MXLPS (MAXLOOPS VL))
(RETURN (FOR NEW P := (MNLPS MXLPS)
NCONC FIRST NIL (KLOOPEDRINGS P VL)))))
EXPR)
(DEFPROP
DAISIES
(LAMBDA
(VL)
(FOR NEW P IN (NUMPARTITIONS
(CAR VL)
(QUOTIENT (FOR NEW X IN (CDR VL)
AS NEW I := (3.0 INFINITY)
UNTIL
(NOT (ZEROP X))
PROG2 I)
2.0)
1.0 0.999999E8)
NCONC FIRST NIL (DAISY (CLCREATE P))))
EXPR)
(DEFPROP
NOLOOPEDRINGS
(LAMBDA
(VL)
(IF (ZEROP (CAR VL))
THEN
(CATALOG (CDR VL))
ELSE
(PROG (BP)
(SETQ BP (BIVALENTPARTITIONS VL))
(RETURN (FOR NEW S IN (CATALOG (CDR VL))
FOR NEW P IN BP NCONC FIRST NIL
(ATTACHBIVALENTS (CLCREATE P)
S))))))
EXPR)
(DEFPROP ROWS (LAMBDA (LL)
(IF (NOT LL)
THEN
(QUOTE (NIL))
ELSE
(CONS (CARLIST LL)
(ROWS (CDRLIST (CDR LL))))))
EXPR)
(DEFPROP BIVALENTPARTITIONS
(LAMBDA (VL)
(NUMPARTITIONS (CAR VL)
(QUOTIENT (FOR NEW I := (3.0 INFINITY)
AS NEW X IN
(CDR VL)
PLUS
(TIMES I X))
2.0)
0.0
(CAR VL)))
EXPR)
(DEFPROP
FREEVALENCESIZE
(LAMBDA (S)
(IF (STRUCTURE? S)
THEN
(FOR NEW X IN (CTABLE S)
FOR NEW Y IN (NBRS X)
WHEN
(EQ Y (QUOTE FV))
PLUS 1.0)
ELSEIF
(STRUCFORM? S)
THEN
(IF (EQ (CAR (FORM S))
(QUOTE ATTACHFVS))
THEN
(FOR NEW FVL IN (CADR (FORM S))
FOR NEW X IN FVL AS NEW I := (1.0 INFINITY)
PLUS
(TIMES I X))
ELSE
(FREEVALENCESIZE (CADDR (FORM S))))
ELSE
(HELP "WHAT'S THE FREE VALNECE OF" S)))
EXPR)
(DEFPROP NODES (LAMBDA (STRUC)
(FOR NEW CT IN (CTABLE STRUC)
LIST
(NODENUM CT)))
EXPR)
(DEFPROP COLLECTFV (LAMBDA (S)
(FOR NEW CT IN (CTABLE S)
FOR NEW X IN (NBRS CT)
WHEN
(EQ X (QUOTE FV))
XLIST
(NODENUM CT)))
EXPR)
(DEFPROP TRIMZEROS
(LAMBDA
(L)
(PROG NIL (RETURN (IF (NULL L)
THEN NIL ELSEIF (ZEROP (PLUSLIST
L))
THEN NIL ELSE
(CONS (CAR L)
(TRIMZEROS (CDR L)))))))
EXPR)
(DEFPROP CATALOG (LAMBDA
(L)
(IF (AND (EQUAL (PLUSLIST (SETQ L (TRIMZEROS L)))
2.0)
(EQUAL (CAR (LAST L))
2.0))
THEN
(LIST (STRUCWITH2NODES (PLUS 2.0 (LENGTH L))))
ELSE
(CATALOG3 L)))
EXPR)
(DEFPROP STRUCWITH2NODES
(LAMBDA (N)
(STRUCTURE UGRAPH = (CONS (QUOTE MBONDS)
N)
CTABLE =
(LIST (CTENTRY NODENUM = 1.0 NBRS =
(FOR NEW I :=
(1.0 N)
XLIST 2.0))
(CTENTRY NODENUM = 2.0 NBRS =
(FOR NEW I :=
(1.0 N)
XLIST 1.0)))
LASTNODE# = 2.0))
EXPR)
(DEFPROP
CATALOG3
(LAMBDA
(TVL)
(PROG (C)
(COND ((NOT (ZEROP (PLUSLIST (CDR TVL))))
NIL)
(T (SETQ C (NTH CATALOG-LIST (QUOTIENT (CAR TVL)
2.0)))))
(RETURN (IF (AND C (CAR C))
THEN
(CAR C)
ELSE
(LIST (STRUCFORM FORM = (CONS (QUOTE CATALOG)
TVL)))))))
EXPR)
(DEFPROP DAISY
(LAMBDA (PART)
(PROG (S C)
(SETQ LASTNODE 1.0)
(SETQ S (STRUCTURE UGRAPH =
(CONS (QUOTE DAISY)
PART)
CTABLE =
(LIST (CTENTRY NODENUM =
LASTNODE))
LASTNODE# = LASTNODE))
(SETQ C LASTNODE)
(FOR NEW PAIR IN PART FOR NEW I :=
(1.0 (CDR PAIR))
DO
(SETQ S (PUTBIVN S C (CAR PAIR))))
(RETURN (LIST S))))
EXPR)
(DEFPROP SINGLERING (LAMBDA (N)
(PROG (S)
(SETQ LASTNODE 0.0)
(SETQ S (BIVCHAIN N))
(CONNECT
(CAR (CTABLE S))
(CAR (LAST (CTABLE S))))
(RETURN (STRUCTURE
FROM S UGRAPH =
(CONS (QUOTE SINGLERING)
N)))))
EXPR)
(DEFPROP BIVCHAIN (LAMBDA (N)
(PROG (X)
(FOR NEW I := (1.0 N)
DO
(SETQ X (PUTNEWNODE X)))
(RETURN X)))
EXPR)
(DEFPROP CONNECT (LAMBDA (X Y)
(PROG NIL (REPLACE (NBRS X)
(CONS (NODENUM Y)
(NBRS X)))
(COND ((NOT (EQ X Y))
(REPLACE (NBRS Y)
(CONS (NODENUM X)
(NBRS Y)))))))
EXPR)
(DEFPROP COPYSTRUC (LAMBDA (S)
(PROG2 (SETQ LASTNODE (LASTNODE# S))
(COPY S)))
EXPR)
(DEFPROP DISCONNECT (LAMBDA (X Y)
(PROG NIL (REPLACE (NBRS X)
(DELETE (NODENUM
Y)
(NBRS X)))
(REPLACE (NBRS Y)
(DELETE (NODENUM X)
(NBRS Y)))))
EXPR)
(DEFPROP FINDCTE (LAMBDA (N LST)
(COND ((NUMBERP N)
(COND ((STRUCTURE? LST)
(SETQ LST (CTABLE LST)))
(T NIL))
(FOR NEW L IN LST WHEN
(EQUAL (NODENUM L)
N)
DO
(RETURN L)))
((NUMBERP LST)
(FINDCTE LST N))
(T (ERROR (QUOTE (BAD ARGUMENTS TO
FINDCTE))))))
EXPR)
(DEFPROP FIRSTOFNODES (LAMBDA (X)
(NODENUM (CAR (CTABLE X))))
EXPR)
(DEFPROP LASTOFNODES (LAMBDA (X)
(NODENUM (CAR (LAST (CTABLE X)))))
EXPR)
(DEFPROP LISTBYVALENCE
(LAMBDA (S)
(PROG (M V)
(SETQ M (LENGTH (CTABLE S)))
(RETURN (FOR NEW I := (2.0 INFINITY)
WHILE
(GREATERP M 0.0)
LIST
(SETQ V (VALENCETYPE S I))
(SETQ M (DIFFERENCE M
(LENGTH
V)))
V))))
EXPR)
(DEFPROP PUTFVN (LAMBDA
(S N J)
(PROG NIL (SETQ N (FINDCTE N (CTABLE S)))
(REPLACE (NBRS N)
(NCONC (NBRS N)
(FOR NEW I := (1.0 J)
XLIST
(QUOTE FV))))
(RETURN S)))
EXPR)
(DEFPROP PUTFVS
(LAMBDA (S FVP)
(PROG2 (FOR NEW NI IN FVP FOR NEW NIJ IN NI AS NEW J
:= (1.0 10.0)
FOR NEW NODE IN NIJ DO
(SETQ S (PUTFVN S NODE J)))
S))
EXPR)
(DEFPROP PUTNEWNODE
(LAMBDA (STRUC)
(COND (STRUC (PROG2 (SETQ LASTNODE
(ADD1 (LASTNODE# STRUC)))
(STRUCTURE FROM STRUC CTABLE =
(PUTNEWNODEINCT
(CTENTRY NODENUM =
LASTNODE)
(CTABLE OF STRUC))
LASTNODE# = LASTNODE))
)
(T (PROG2 (SETQ LASTNODE (ADD1 LASTNODE))
(STRUCTURE CTABLE =
(LIST (CTENTRY NODENUM =
LASTNODE))
LASTNODE# = LASTNODE)))))
EXPR)
(DEFPROP PUTNEWNODEINCT (LAMBDA (X Y)
(PROG (Z)
(SETQ Z (CAR Y))
(REPLACE (NBRS OF Z)
(CONS (NODENUM X)
(NBRS Z)))
(REPLACE (NBRS OF X)
(CONS (NODENUM Z)
(NBRS X)))
(RETURN (CONS X Y))))
EXPR)
(DEFPROP NODEVALENCE (LAMBDA (NODE)
(COND ((NULL NODE)
(ERROR (QUOTE (NULL NODE GIVEN TO
NODEVALENCE))))
((CTENTRY? NODE)
(LENGTH (NBRS NODE)))
(T (NODEVALENCE
(FINDCTE (CAR NODE)
(CDR NODE))))))
EXPR)
(DEFPROP VALENCETYPE (LAMBDA (S I)
(FOR NEW NODE IN (CTABLE S)
WHEN
(EQUAL I (NODEVALENCE NODE))
XLIST
(NODENUM NODE)))
EXPR)
(DEFPROP SINGLERINGS (LAMBDA (N)
(LIST (SINGLERING N)))
EXPR)
(DEFPROP INSERTMARKERS
(LAMBDA
(STRUC CLL L)
(PROG NIL
(FOR NEW CL IN CLL AS NEW NLL IN L FOR NEW PAIR IN
CL AS NEW NL IN NLL FOR NEW N IN NL DO
(REPLACE (ATOMTYPE (MARKERS (FINDCTE N STRUC)))
(CAR PAIR)))
(RETURN STRUC)))
EXPR)
(DEFPROP DELETE (LAMBDA (I L)
(COND ((NULL L)
NIL)
((EQUAL (CAR L)
I)
(CDR L))
(T (CONS (CAR L)
(DELETE I (CDR L))))))
EXPR)
STOP